home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / jockguts.arc / FASTTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-28  |  12KB  |  419 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.01                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  FastTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-,D-}       
  18.  
  19. unit FastTTT5;
  20.  
  21. {Change history:  4/01/89 5.00a    Changed VertLine and Horizline
  22. }
  23.  
  24. interface
  25.  
  26. Uses DOS, CRT;
  27.  
  28. const
  29.     MaxScreenStr = 80;
  30.     FCol:byte = white;
  31.     BCol:byte = black;
  32. type
  33.   StrScreen = string[MaxScreenStr];
  34. var
  35.   BaseOfScreen : Word;       {Base address of video memory}
  36.   VSeg : word;               {Base address of active screen}
  37.   VOfs : word;                   {Base address of active screen}
  38.   SnowProne : Boolean;       {Check for snow on color cards?}
  39.   Speed : longint;           {delay factor for growbox routine}
  40.  
  41. Function  ColorScreen:boolean;
  42. Function  Attr(F,B:byte):byte;
  43. Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen);
  44. Procedure PlainWrite(Col,Row:byte; St:StrScreen);
  45. Procedure ColWrite(Col,Row:byte; St:StrScreen);
  46. Procedure FWrite(St:StrScreen);
  47. Procedure FWriteLN(St:StrScreen);
  48. Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  49. Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  50. Function  Replicate(N:byte; Character:char):StrScreen;
  51. Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  52. Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  53. Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  54. Procedure HorizLine(X1,X2,Y,F,B,lineType:byte);
  55. Procedure VertLine(X,Y1,Y2,F,B,lineType:byte);
  56. Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  57. Procedure ClearLine(Y,F,B:integer);
  58. Procedure WriteAT(X,Y,F,B:integer; St:StrScreen);
  59. Procedure WriteBetween(X1,X2,Y,F,B:byte; St:StrScreen);
  60. Procedure WriteCenter(LineNO,F,B:integer; St:StrScreen);
  61. Procedure WriteVert(X,Y,F,B:integer; St:StrScreen);
  62. Function  EGAVGASystem: boolean;
  63. Procedure InitFastTTT;
  64.  
  65. implementation
  66.  
  67.   {$L FASTTTT5}
  68.  
  69.   {$F+}
  70.   Procedure FastWrite(Col,Row,Attr:byte; St:StrScreen); external;
  71.   Procedure PlainWrite(Col,Row:byte; St:StrScreen); external;
  72.   Procedure Attribute(Col,Row,Attr:byte; Number:Word); external;
  73.   {$F-}
  74.  
  75.   Function ColorScreen: boolean;
  76.   {}
  77.   begin
  78.       ColorScreen := (BaseOfScreen = $B800);
  79.   end; {of func ColorScreen}
  80.  
  81.   Function Attr(F,B:byte):byte;
  82.   {converts foreground(F) and background(B) colors to combined Attribute byte}
  83.   begin
  84.       Attr := (B Shl 4) or F;
  85.   end;  {Func Attr}
  86.  
  87.   Procedure ColWrite(Col,Row:byte; St:StrScreen);
  88.   begin
  89.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  90.   end;
  91.  
  92.   Procedure FWrite(St:StrScreen);
  93.   var Col,Row : byte;
  94.   begin
  95.       Col := WhereX;
  96.       Row := WhereY;
  97.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  98.       GotoXY(Col+length(St),Row);
  99.   end;
  100.  
  101.   Procedure FWriteLN(St:StrScreen);
  102.   var Col,Row : byte;
  103.   begin
  104.       Col := WhereX;
  105.       Row := WhereY;
  106.       Fastwrite(Col,Row,attr(FCol,BCol),St);
  107.       GotoXY(1,succ(Row));
  108.   end;
  109.  
  110.   
  111.  
  112.   Procedure Attrib(X1,Y1,X2,Y2,F,B:byte);
  113.   {changes color attrib at specified coords}
  114.   var
  115.     I,X,A : byte;
  116.   begin
  117.       A := Attr(F,B);
  118.       X := Succ(X2-X1);
  119.       For I := Y1 to Y2 do
  120.           Attribute(X1,I,A,X);
  121.   end; {Proc Attrib}
  122.  
  123.  
  124.   Procedure Clickwrite(Col,Row,F,B:byte; St:StrScreen);
  125.   {writes text to the screen with a click!}
  126.   var
  127.     I : Integer;
  128.     L,A : byte;
  129.   begin
  130.       A := attr(F,B);
  131.       L := length(St);
  132.       For I := L downto 1 do
  133.       begin
  134.           Fastwrite(Col,Row,A,copy(St,I,succ(L-I)));
  135.           sound(500);delay(20);nosound;delay(30);
  136.       end;
  137.   end;
  138.  
  139.   Function Replicate(N : byte; Character:char):StrScreen;
  140.   {returns a string with Character repeated N times}
  141.   var tempstr : StrScreen;
  142.   begin
  143.       If N = 0 then
  144.          TempStr := ''
  145.       else
  146.       begin
  147.          If (N > 80) then
  148.             N := 1;
  149.          fillchar(tempstr,N+1,Character);
  150.          Tempstr[0] := chr(N);
  151.       end;
  152.       Replicate := Tempstr;
  153.   end;
  154.  
  155.   Procedure ClearText(x1,y1,x2,y2,F,B:integer);
  156.   var
  157.     Y : integer;
  158.     attrib : byte;
  159.   begin
  160.       If x2 > 80 then x2 := 80;
  161.       Attrib := attr(F,B);
  162.       For Y := y1 to y2 do
  163.           Fastwrite(X1,Y,attrib,replicate(X2-X1+1,' '));
  164.   end;   {cleartext}
  165.  
  166.   Procedure ClearLine(Y,F,B:integer);
  167.   begin
  168.       Fastwrite(1,Y,attr(F,B),replicate(80,' '));
  169.   end;
  170.  
  171.   Procedure Box(X1,Y1,X2,Y2,F,B,boxtype:integer);
  172.   {Draws a box on the screen}
  173.   var
  174.     I:integer;
  175.     corner1,corner2,corner3,corner4,
  176.     horizline,
  177.     vertline : char;
  178.     attrib : byte;
  179.   begin
  180.       case boxtype of
  181.       0:begin
  182.             corner1:=' ';
  183.             corner2:=' ';
  184.             corner3:=' ';
  185.             corner4:=' ';
  186.             horizline:=' ';
  187.             vertline:=' ';
  188.         end;
  189.       1:begin
  190.             corner1:='┌';
  191.             corner2:='┐';
  192.             corner3:='└';
  193.             corner4:='┘';
  194.             horizline:='─';
  195.             vertline:='│';
  196.         end;
  197.       2:begin
  198.             corner1:='╔';
  199.             corner2:='╗';
  200.             corner3:='╚';
  201.             corner4:='╝';
  202.             horizline:='═';
  203.             vertline:='║';
  204.         end;
  205.       3:begin
  206.             corner1:='╓';
  207.             corner2:='╖';
  208.             corner3:='╙';
  209.             corner4:='╜';
  210.             horizline:='─';
  211.             vertline:='║';
  212.         end;
  213.       4:begin
  214.             corner1:='╒';
  215.             corner2:='╕';
  216.             corner3:='╘';
  217.             corner4:='╛';
  218.             horizline:='═';
  219.             vertline:='│';
  220.         end;
  221.     else
  222.        corner1:=chr(ord(Boxtype));
  223.        corner2:=chr(ord(Boxtype));
  224.        corner3:=chr(ord(Boxtype));
  225.        corner4:=chr(ord(Boxtype));
  226.        horizline:=chr(ord(Boxtype));
  227.        vertline:=chr(ord(Boxtype));
  228.     end;{case}
  229.     attrib := attr(F,B);
  230.     FastWrite(X1,Y1,attrib,corner1);
  231.     FastWrite(X1+1,Y1,attrib,replicate(X2-X1-1,horizline));
  232.     FastWrite(X2,Y1,attrib,corner2);
  233.     For I := Y1+1 to Y2-1 do
  234.     begin
  235.         FastWrite(X1,I,attrib,vertline);
  236.         FastWrite(X2,I,attrib,vertline);
  237.     end;
  238.     FastWrite(X1,Y2,attrib,corner3);
  239.     FastWrite(X1+1,Y2,attrib,replicate(X2-X1-1,horizline));
  240.     FastWrite(X2,Y2,attrib,corner4);
  241.   end; {Proc Box}
  242.  
  243.   Procedure FBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  244.   {Draws a box and clears text within Box frame}
  245.   begin
  246.       Box(X1,Y1,X2,Y2,F,B,boxtype);
  247.       ClearText(succ(X1),succ(Y1),pred(X2),pred(Y2),F,B);
  248.   end;
  249.  
  250.   Procedure GrowFBox(X1,Y1,X2,Y2,F,B,boxtype:integer);
  251.   {Draws exploding filled box!}
  252.   var I,TX1,TY1,TX2,TY2,Ratio : integer;
  253.   begin
  254.       If 2*(Y2 -Y1 +1) > X2 - X1 + 1 then
  255.          Ratio :=   2
  256.       else
  257.          Ratio :=  1;
  258.       TX2 := (X2 - X1) div 2 + X1 + 2;
  259.       TX1 := TX2 - 3;                 {needs a box 3 by 3 minimum}
  260.       TY2 := (Y2 - Y1) div 2 + Y1 + 2;
  261.       TY1 := TY2 - 3;
  262.       If (X2-X1) < 3 then
  263.       begin
  264.          TX2 := X2;
  265.          TX1 := X1;
  266.       end;
  267.       If (Y2-Y1) < 3 then
  268.       begin
  269.          TY2 := Y2;
  270.          TY1 := Y1;
  271.       end;
  272.       repeat
  273.            FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  274.            If TX1 >= X1 + (1*Ratio) then TX1 := TX1 - (1*Ratio) else TX1 := X1;
  275.            If TY1 > Y1  then TY1 := TY1 - 1;
  276.            If TX2 + (1*Ratio) <= X2 then TX2 := TX2 + (1*Ratio) else TX2 := X2;
  277.            If TY2 + 1 <= Y2 then TY2 := TY2 + 1;
  278.            For I := 1 to Speed*1000 do {nothing};
  279.       Until (TX1 = X1) and (TY1 = Y1) and (TX2 = X2) and (TY2 = Y2);
  280.       FBox(TX1,TY1,TX2,TY2,F,B,BoxType);
  281.   end;
  282.  
  283.   procedure HorizLine(X1,X2,Y,F,B,lineType : byte);
  284.   var
  285.     I : integer;
  286.     Horizline : char;
  287.     attrib : byte;
  288.   begin
  289.       case LineType of                     {5.00a}
  290.       0       : HorizLine := ' ';
  291.       2,4,7,9 : Horizline := '═';
  292.       1,3,6,8 : HorizLine := '─';
  293.       else HorizLine := Chr(LineType);
  294.       end; {case}
  295.       Attrib := attr(F,B);
  296.       If X2 > X1 then
  297.          FastWrite(X1,Y,attrib,replicate(X2-X1+1,Horizline))
  298.       else
  299.          FastWrite(X1,Y,attrib,replicate(X1-X2+1,Horizline));
  300.   end;   {horizline}
  301.  
  302.   Procedure VertLine(X,Y1,Y2,F,B,lineType : byte);
  303.   var
  304.     I : integer;
  305.     vertline : char;
  306.     attrib : byte;
  307.   begin
  308.       case LineType of                {5.00a}
  309.       0       : VertLine := ' ';
  310.       2,4,7,9 : Vertline := '║';
  311.       1,3,6,8 : VertLine := '│';
  312.       else VertLine := Chr(LineType);
  313.       end; {case}
  314.       Attrib := attr(F,B);
  315.       If Y2 > Y1 then
  316.          For I := Y1 to Y2 do Fastwrite(X,I,Attrib,Vertline)
  317.       else
  318.          For I := Y2 to Y1 do Fastwrite(X,I,Attrib,Vertline);
  319.   end;   {vertline}
  320.  
  321.   Procedure WriteAT(X,Y,F,B:integer;St:StrScreen);
  322.   begin
  323.       Fastwrite(X,Y,attr(F,B),St);
  324.   end;
  325.  
  326.   Procedure WriteCenter(LineNO,F,B:integer;St:StrScreen);
  327.   begin
  328.       Fastwrite(40 - length(St) div 2,Lineno,attr(F,B),St);
  329.   end;
  330.  
  331.   Procedure WriteBetween(X1,X2,Y,F,B:byte;St:StrScreen);
  332.   var X : integer;
  333.   begin
  334.       If length(St) >= X2 - X1 + 1 then
  335.          WriteAT(X1,Y,F,B,St)
  336.       else
  337.       begin
  338.           x := X1 + (X2 - X1 + 1 - length(St)) div 2 ;
  339.           WriteAT(X,Y,F,B,St);
  340.       end;
  341.   end;
  342.  
  343.   Procedure WriteVert(X,Y,F,B:integer;ST : StrScreen);
  344.   var
  345.     I:integer;
  346.     Tempstr:StrScreen;
  347.   begin
  348.       If length(St) > 26 - Y then delete(St,27 - Y,80);
  349.       For I := 1 to length(St) do
  350.       begin
  351.           Tempstr := st[I];
  352.           Fastwrite(X,Y-1+I,attr(F,B),St[I]);
  353.       end;
  354.   end;
  355.  
  356.   Function EGAVGASystem: boolean;
  357.   {}
  358.   var  Regs : registers;
  359.   begin
  360.       with Regs do
  361.       begin
  362.           Ax := $1C00;
  363.           Cx := 7;
  364.           Intr($10,Regs);
  365.           If Al = $1C then  {VGA}
  366.           begin
  367.               EGAVGASystem := true;
  368.               exit;
  369.           end;
  370.           Ax := $1200;
  371.           Bl := $32;
  372.           Intr($10,Regs);
  373.           If Al = $12 then {MCGA}
  374.           begin
  375.               EGAVGASystem := true;
  376.               exit;
  377.           end;
  378.           Ah := $12;
  379.           Bl := $10;
  380.           Cx := $FFFF;
  381.           Intr($10,Regs);
  382.           EGAVGASystem := (Cx <> $FFFF);  {EGA}
  383.      end; {with}
  384.   end; {of func NoSnowSystem}
  385.  
  386.   Function Get_Video_Mode:byte;
  387.   {}
  388.   var
  389.      Regs : registers;
  390.   begin
  391.       with Regs do
  392.       begin
  393.           Ax := $0F00;
  394.           Intr($10,Regs);
  395.           Get_Video_Mode := Al;
  396.       end; {with}
  397.   end; {of proc Video_Mode}
  398.  
  399.   Procedure InitFastTTT;
  400.   begin
  401.       if Get_Video_Mode = 7 then
  402.       begin
  403.          BaseOfScreen := $B000;  {Mono}
  404.          SnowProne := False;
  405.       end
  406.       else
  407.       begin
  408.          BaseOfScreen := $B800; {Color}
  409.          SnowProne := not EGAVGASystem;
  410.       end;
  411.       VSeg := BaseOfScreen;
  412.       Vofs := 0;
  413.   end;
  414.  
  415. begin   {the following is always called when the unit is loaded}
  416.     InitFastTTT;
  417.     Speed := 200;
  418. end.
  419.